Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue55/Contain/FlexiSort.pas

Pascal/Delphi Source File | 2000-02-02 | 6.4 KB | 273 lines

unit FlexiSort;

interface

uses
  SysUtils, TypInfo, Classes, Dialogs;

type

{$TYPEINFO ON}
  TRTTIObject = class (TObject)
  end;
{$TYPEINFO OFF}

  EFlexiSortListError = class(Exception);

  TSortItem = record
    PPI: PPropInfo;
    Descending: Boolean;
    Kind: TTypeKind;
  end;

  TSortItems = array of TSortItem;

  TFlexiSortList = class(TObject)
  private
    ContainedClassType: TClass;
    List: TList;
    SortItems: TSortItems;
  protected
    function CompareItems(Item1, Item2: Pointer): Integer;
    function Get(Index: Integer): TObject;
    function GetCapacity: Integer;
    function GetCount: Integer;
    procedure InitializeSortItems(const SortFields: array of String);
    procedure Put(Index: Integer; Item: TObject);
    procedure QuickFlexiSort(SortList: PPointerList; L, R: Integer);
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
  public
    constructor Create(ClassType: TClass);
    destructor Destroy; override;
    function Add(Item: TObject): Integer;
    procedure Clear;
    procedure Delete(Index: Integer);
    procedure Pack;
    function Remove(Item: TObject): Integer;
    procedure Sort(const SortFields: array of String);
    property Capacity: Integer read GetCapacity write SetCapacity;
    property Count: Integer read GetCount write SetCount;
    property Items[Index: Integer]: TObject read Get write Put; default;
  end;

implementation

{ TFlexiSortList }

function TFlexiSortList.Add(Item: TObject): Integer;
begin
  if Item.ClassType <> ContainedClassType then
    raise EFlexiSortListError.Create('Add attempted for object not ' +
        'of class type ' + ContainedClassType.ClassName);
  Result := List.Add(Item);
end;

procedure TFlexiSortList.Clear;
begin
  List.Clear;
end;

function TFlexiSortList.CompareItems(Item1, Item2: Pointer): Integer;
var
  I: Integer;
  PPI: PPropInfo;

  function CompareOrd(I1, I2: LongInt): Integer;
  begin
    if I1 > I2 then
      Result := 1
    else if I1 = I2 then
      Result := 0
    else
      Result := -1;
    end;

  function CompareFloat(I1, I2: Extended): Integer;
  begin
    if I1 > I2 then
      Result := 1
    else if I1 = I2 then
      Result := 0
    else
      Result := -1;
    end;

  function CompareInt64(I1, I2: Int64): Integer;
  begin
    if I1 > I2 then
      Result := 1
    else if I1 = I2 then
      Result := 0
    else
      Result := -1;
    end;

begin
  Result := 0;
  I := 0;
  while ((Result = 0) and (I < Length(SortItems))) do
  begin
    PPI := SortItems[I].PPI;
    if PPI <> nil then
    begin
      case SortItems[I].Kind of
        tkInteger,
        tkChar,
        tkEnumeration:
          Result := CompareInt64(GetOrdProp(Item1, PPI),
              GetOrdProp(Item2, PPI));
        tkFloat:
          Result := CompareFloat(GetFloatProp(Item1, PPI),
              GetFloatProp(Item2, PPI));
        tkString,
        tkLString,
        tkWString:
          Result := AnsiCompareStr(GetStrProp(Item1, PPI),
              GetStrProp(Item2, PPI));
        tkInt64:
          Result := CompareInt64(GetInt64Prop(Item1, PPI),
              GetInt64Prop(Item2, PPI));
      end;
    end;
    if Result = 0 then
      Inc(I)
    else if SortItems[I].Descending then
      Result := -Result;
  end;
end;

constructor TFlexiSortList.Create(ClassType: TClass);
begin
  inherited Create;
  List := TList.Create;
  ContainedClassType := ClassType;
end;

procedure TFlexiSortList.Delete(Index: Integer);
begin
  List.Delete(Index);
end;

destructor TFlexiSortList.Destroy;
begin
  List.Free;
  inherited Destroy;
end;

function TFlexiSortList.Get(Index: Integer): TObject;
begin
  Result := TObject(List[Index]);
end;

function TFlexiSortList.GetCapacity: Integer;
begin
  Result := List.Capacity;
end;

function TFlexiSortList.GetCount: Integer;
begin
  Result := List.Count;
end;

procedure TFlexiSortList.InitializeSortItems(
    const SortFields: array of String);
var
  I: Integer;
  S: String;
  PPI: PPropInfo;
  PTI: PTypeInfo;
  TK: TTypeKind;
begin
  SetLength(SortItems, High(SortFields) + 1);
  for I := 0 to High(SortFields) do
  begin
    SortItems[I].PPI := nil;
    SortItems[I].Descending := False;
    if Copy(SortFields[I], 1, 2) = 'D:' then
    begin
      SortItems[I].Descending := True;
      S := Copy(SortFields[I], 3, $7FFF);
    end
    else if Copy(SortFields[I], 1, 2) = 'A:' then
      S := Copy(SortFields[I], 3, $7FFF)
    else
      S := SortFields[I];
    PPI := GetPropInfo(ContainedClassType.ClassInfo, S);
    if PPI = nil then
      raise EFlexiSortListError.Create('Sort item ' + S +
          ' is not a published property for ' +
          ContainedClassType.ClassName);
    SortItems[I].PPI := PPI;
    PTI := PPI.PropType^;
    TK := PTI.Kind;
    if not (TK in [tkInteger, tkChar, tkEnumeration, tkFloat,
        tkString, tkLString, tkWString, tkInt64]) then
      raise EFlexiSortListError.Create('Sort item ' + S +
          ' is not a valid type for sorting in class ' +
          ContainedClassType.ClassName);
    SortItems[I].Kind := TK;
  end;
end;

procedure TFlexiSortList.Pack;
begin
  List.Pack;
end;

procedure TFlexiSortList.Put(Index: Integer; Item: TObject);
begin
  List[Index] := Item;
end;

procedure TFlexiSortList.QuickFlexiSort(SortList: PPointerList;
    L, R: Integer);
var
  I, J: Integer;
  P, T: Pointer;
begin
  repeat
    I := L;
    J := R;
    P := SortList^[(L + R) shr 1];
    repeat
      while CompareItems(SortList^[I], P) < 0 do Inc(I);
      while CompareItems(SortList^[J], P) > 0 do Dec(J);
      if I <= J then
      begin
        T := SortList^[I];
        SortList^[I] := SortList^[J];
        SortList^[J] := T;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then QuickFlexiSort(SortList, L, J);
    L := I;
  until I >= R;
end;

function TFlexiSortList.Remove(Item: TObject): Integer;
begin
  Result := List.Remove(Item);
end;

procedure TFlexiSortList.SetCapacity(NewCapacity: Integer);
begin
  List.Capacity := NewCapacity;
end;

procedure TFlexiSortList.SetCount(NewCount: Integer);
begin
  List.Count := NewCount;
end;

procedure TFlexiSortList.Sort(const SortFields: array of String);
begin
  InitializeSortItems(SortFields);
  if List.Count > 0 then
    QuickFlexiSort(List.List, 0, (List.Count - 1));
end;

end.